perm filename INTRIN.L70[L70,TES] blob
sn#015166 filedate 1972-12-01 generic text, type T, neo UTF8
00100 ACCESS METHOD PRIVATE, PUBLIC ;
00200
00300
00400
00500
00600 RELOCATABILITY SHARED ;
00700
00800 DATA TYPE
00900 IDENTIFIER|BOOLEAN (PNAME, PROPERTIES),
01000 TYPE "TYPE?$TABLE" (NAME),
01100 LIST "CONS"(CAR, CDR),
01200 INTEGER (NUMVAL),
01300 % THE ABOVE ARE REALLY DEFINED IN INIT %
01400 FUNCTION,
01500 FIELD,
01600 % ALL OF THE ABOVE MUST BE DEFINED IN EXACT ORDER %
01700 STRING "MK?$STRING" [1:*]/7,
01800 STREAM "SCONS"(FIRST, REST)<10,100>,
01900 STACK,
02000 MAP?$TABLE, %REALLY DEFINED IN COMP, AS A RECORD CLASS%
02100 VECTOR?$BLOCK,
02200 TRANSFER?$VECTOR,
02300 TCHARACTER?$TABLE[0:128],
02400 TTRANSITION?$TABLE[0:*],
02500 REWRITE,
02600 EOF,
02700 PUBIC?$VARIABLE (VALUE)<10,10> ;
02800
02900
03000 DATA TYPE
03100 TUPLE [1:*],
03200 VECTOR [1:*],
03300 ARRAY [*:*] ;
03400
03500
03600 DATA TYPE
03700 SCN?$TABLE (TCHARACTER?$TABLE CHARACTER?$TABLE; TTRANSITION?$TABLE TRANSITION?$TABLE)<2,2>;
03800
03900
04000 DATA TYPE
04100 FILE (STRING FILE?$NAME; INTEGER CHANNEL; STRING MODE; INTEGER RECORD?$NUMBER; BOOLEAN FOR?$INPUT;
04200 SCN?$TABLE SCANNER; STRING SCN?$STRING; INTEGER NO?$OF?$BUFFERS, BUFFER?$SIZE;
04300 ARRAY HEADER)<2,3>;
04400
04500
04600 INCLUDE SCNTAB.L70 ; % LISP70_SCANNER %
04700
04800
04900 BYTE LAST_PHYSICAL(BH) = _LH(_CORE(BH)) ;
05000 BYTE NEXT_PHYSICAL(BH) = _RH(_CORE(BH)) ;
05100 BYTE LAST_FREE(BH) = _LH(_CORE(BH+2)) ;
05200 BYTE NEXT_FREE(BH) = _RH(_CORE(BH+2)) ;
05300 BYTE OCCUPIED(BH) = _LH(_CORE(BH+1)) ;
05400 BYTE SWEEPABLE(BH) = _RH(_CORE(BH+1)) ;
05500
05600 BYTE TO_HEADER(DA) = _LH(_CORE(DA-1)) ;
05700 BYTE TO_BACK_POINTER(DA) = _RH(_CORE(DA-1)) ;
05800
05900 BYTE FREE_LINK(DA) = _RH(_CORE(DA-2)) ;
06000 BYTE RECORD_TYPE(DA) = _LH(_CORE(DA-2)) ;
06100
06200 BYTE TO_FREE_VECTOR(DA) = _RH(_CORE(DA-2)) ;
06300 BYTE TO_FIRST_VECTOR(DA) = _LH(_CORE(DA-2)) ; %SAME AS TO_NEXT_VECTOR(VDA)%
06400
06500 BYTE TO_NEXT_VECTOR(VDA) = _LH(_CORE(VDA-2)) ;
06600 BYTE ELEMENTS(VDA) = _RH(_CORE(VDA-2)) ;
06700 BYTE LHALF(LOC)=_LH(_CORE(LOC));
06800 BYTE RHALF(LOC)=_RH(_CORE(LOC));
06900
07000
07100 LET BACK?$POINTER = <INTEGER:BH> → <:_CORE(BH+2)> ;
07200
07300 LET OUT = <STRING:X> → <STRING> FORWARD;
07400
07500 LET OUTCHR = <INTEGER:X> → <INTEGER> FORWARD;
07600
07700 LET INITUUO = <INTEGER:CHANNEL,MODE,DEV6BIT> → <BOOLEAN> FORWARD ;
07800
07900 LET FILEUUO = <INTEGER:OPCODE,CHANNEL,FILENAME6BIT,EXT6BIT,PPN6BIT> → <BOOLEAN> FORWARD ;
08000
08100 LET IOUUO = <INTEGER:OPCODE,AC,ADDR> → <BOOLEAN> FORWARD ;
08200
08300 LET SCANFILE = <FILE:FIL> → <ENTITY> FORWARD ;
08400
08500 LET SAVE4ACS = <> → NIL & FORWARD ;
08600
08700 LET RESTORE4ACS = <> → NIL & FORWARD ;
08800
08900 LET EX?$SCN?$STRING = <STRING:SCNSTR> → <STRING>
09000 ERROR("I DON'T EXPAND SCAN STRINGS YET") ;
09100
09200 LET UUO = <> → NIL & FORWARD ;
09300
09400 GLOBAL INTEGER FREE?$BLOCKS, BLOCK?$HEADER?$LENGTH, CORE?$TOP, BUFFER?$HEADERS, INFINITY ;
09500
09600 GLOBAL STACK P?$STACK, D?$STACK ;
09700
09800
09900 GLOBAL BOOLEAN LIST BUSY?$CHANNELS ;
10000
10100
10200 GLOBAL TYPE STRING?$TYPE ;
10300
10400
10500
10600 LET START70 = <INTEGER:FB,BUFHDRS> <STACK:PDESC,DDESC> → NIL &
10700 BEGIN
10800 BLOCK?$HEADER?$LENGTH ← 3 ;
10900 FREE?$BLOCKS ← FB ;
11000 BUFFER?$HEADERS ← BUFHDRS ;
11100 BUSY?$CHANNELS ← SEQUENCE(16) ;
11200 P?$STACK ← PDESC ; D?$STACK ← DDESC ;
11300 CORE?$TOP ← NEXT_PHYSICAL(FB) ;
11400 STRING?$TYPE ← TYPE("X") ;
11500 INFINITY ← `77777 ;
11600 IF _CALLI(_VAL_, `400021 %SEGNUM%, 0) + 0 = 0 % NO SEGMENT % THEN
11700 IF ¬_CALLI(_VAL_, `37 %REMAP%, BOOLE(7,LSH(0,35),`7777) %SEGFAKE-1%)
11800 THEN ERROR("CAN'T CREATE UPPER SEGMENT.")
11900 ELSE _CALLI(_VAL_, `12, 0) ; %EXIT FOR SSAVE%
12000 OUT?$OF?$CORE(0) ; % ASSURE A MULTIPLE OF 1024 WORDS %
12100 CONTRACT?$CORE() ; % CONTRACT LOWER SEGMENT TO MINIMAL SIZE %
12200 END ;
12300
12400
12500
12600 LET INCONVERT = <STRING:TYP> <STRING:X> → <STRING> STRING(X) ;
12700
12800 = <INTEGER:TYP> <STRING:X> → UNWRITTEN ;
12900
13000 LET OUTCONVERT = <STRING:S> → NIL &
13100 BEGIN
13200 OUTCHR(`42) ; OUT(S) ; OUTCHR(`42) ; % "---" %
13300 END ;
13400
13500 = <IDENTIFIER:X> → NIL & OUT(PNAME(X)) ;
13600
13700 = <LIST:L> → NIL &
13800 BEGIN
13900 OUT("(");
14000 OUTCONVERT(CAR L);
14100 OUT?$CDR(CDR L);
14200 OUT(")");
14300 END;
14400
14500 = <INTEGER:X> → NIL & OUT?$I(X) ;
14600
14700
14800
14900
15000 LET ERROR UUO = <STRING:MSG> → NIL &
15100 BEGIN
15200 BOOLEAN PROGRAMMER?$INTERVENES ;
15300 PRINTSTR(MSG) ;
15400 DO NIL UNTIL PROGRAMMER?$INTERVENES ;
15500 END ;
15600
15700
15800 LET APRTRAP = <INTEGER:JOBCNI,REGLOC,JOBTPC> → NIL &
15900 IF BOOLE(1, JOBCNI, `200000) ≠ 0 THEN %STACK OVERFLOW%
16000 BEGIN
16100 INTEGER DATA, NEWDATA, REG ; STACK S ;
16200 IF _CORE(REGLOC+_P_, INTEGER) > 0 THEN REG ← _P_ ALSO S ← P?$STACK
16300 ELSE IF _CORE(REGLOC+_D_, INTEGER) > 0 THEN REG ← _D_ ALSO S ← D?$STACK
16400 ELSE PRINT _RH(JOBTPC) ALSO ERROR("STACK OVERFLOW -- NOT P OR D") ;
16500 TERPRI NIL ; PRINTSTR("* * * * * EXPANDING STACK * * * * *") ;
16600 DATA ← DATA?$AREA(S) ;
16700 NEWDATA ← EX?$BLOCK(S, 0, 100) ;
16800 S ← BACK?$POINTER(FIND?$HEADER(NEWDATA)) ;
16900 IF REG = _P_ THEN P?$STACK←S ELSE D?$STACK ← S ;
17000 LHALF(REGLOC + REG) ← -100 ;
17100 RHALF(REGLOC + REG) ← RHALF(REGLOC + REG) + (NEWDATA-DATA) ;
17200 PRINTSTR(IF REG = _P_ THEN "* P *" ELSE "* D *") ;
17300 END
17400 ELSE PRINT _RH(JOBTPC) %ERROR% ALSO
17500 IF BOOLE(1, JOBCNI, `20000) ≠ 0 THEN ERROR("ILL MEM REF")
17600 ELSE IF BOOLE(1, JOBCNI,`100) ≠ 0 THEN PRINTSTR("* * * FLOATING OVERFLOW * * *")
17700 ELSE IF BOOLE(1, JOBCNI, `10) ≠ 0 THEN PRINTSTR("* * * INTEGER OVERFLOW * * *")
17800 ELSE PRINTSTR("* * * UNDETERMINED ERROR IN ARITHMETIC PROCESSOR * * * ")
17900 ALSO PRINT(JOBCNI) ;
18000
18100
18200 LET NUMBERP = <INTEGER:X> → <BOOLEAN> T ;
18300
18400 = :OTHER → NIL ;
18500
18600
18700
18800 LET STRINGP = <STRING:X> → <BOOLEAN> T ;
18900
19000 = :OTHER → NIL ;
19100
19200
19300
19400 LET READ = <> → UNWRITTEN ;
19500
19600
19700 LET PRINT = :X → :X &
19800 BEGIN
19900 OUTCONVERT(TERPRI X);
20000 OUT(" ");
20100 END;
20200
20300
20400
20500 LET OUT?$CDR = :L → NIL &
20600 IF NULL L THEN ""
20700 ELSE IF ATOM L THEN OUT(" . ") ALSO OUTCONVERT(L)
20800 ELSE OUT(" ") ALSO OUTCONVERT(CAR L) ALSO OUT?$CDR(CDR L);
20900
21000
21100
21200
21300 LET TERPRI = :X → :X &
21400 OUT("
21500 ");
21600
21700
21800 LET PRINTSTR = <STRING:S> → <STRING>
21900 PROG2(TERPRI(OUT(S)), S);
22000
22100
22200 LET OUT?$I = <INTEGER:X> → NIL &
22300 IF X < 0 THEN OUT("-") ALSO OUT?$I(-X)
22400 ELSE IF X < 10 THEN OUTCHR(X + `60)
22500 ELSE OUT?$I(X/10) ALSO OUTCHR((X REMAINDER 10) +`60);
22600
22700
22800 LET EQUAL = :X :Y → <BOOLEAN>
22900 IF NUMBERP(X) &NUMBERP(Y) THEN NUMVAL(X) EQ NUMVAL(Y)
23000 ELSE IF ATOM(X) & ATOM(Y) THEN X EQ Y
23100 ELSE IF TYPE(X) NEQ TYPE(Y) THEN NIL
23200 ELSE CAR(X) = CAR(Y) & CDR(X) = CDR(Y);
23300
23400 LET EX?$BLOCK = :DESC <INTEGER:BEFORE,AFTER> → <INTEGER>
23500 BEGIN
23600 INTEGER BLK, PREFACE, DATA?$SIZE, DATA, NEWDATA;
23700 DATA ← DATA?$AREA(DESC) ;
23800 BLK ← FIND?$HEADER(DATA) ;
23900 PREFACE ← PREFACEF(DESC);
24000 DATA?$SIZE ← DATA?$SIZEF(DESC);
24100 NEWDATA ← GET?$BLOCK(DESC, PREFACE + BEFORE, DATA?$SIZE + AFTER, SWEEPABLE(BLK));
24200 _BLT(DATA?$SIZE,DATA,NEWDATA);
24300 _BLT(PREFACE, DATA-PREFACE-1, NEWDATA-PREFACE-1);
24400
24500 FORGET?$SPACE(BLK) ;
24600 RETURN (NEWDATA); %RETURNS POINTER TO THE DATA AREA OF BLOCK %
24700 END ;
24800
24900
25000 LET EX?$FIRST?$FIELD = <TYPE:TYP> <FIELD:FLD> <INTEGER:PREFACE?$INCR,DATA?$INCR> → <INTEGER>
25100 BEGIN INTEGER HAD,DATA,TY,HI,I;
25200 PRINTSTR("*********************** EXPANDING:");
25300 PRINT(NAME(TYP));
25400 HAD←EX?$FIELD(FLD,PREFACE?$INCR,DATA?$INCR);
25500 DATA←DATA?$AREA(FLD);
25600 TY ← RECORD_TYPE(DATA) ;
25700 I←HAD+1;
25800 HI←HAD+DATA?$INCR;
25900 WHILE I ≤ HI DO
26000 BEGIN
26100 RHALF(DATA+I)←I+1;
26200 LHALF(DATA+I)←TY;
26300 I←I+1;
26400 END ;
26500 RHALF(DATA+HI)← -1;
26600 FREE_LINK(DATA) ← HAD+1 ;
26700 END;
26800
26900 LET EX?$FIELD = <FIELD:FLD> <INTEGER:PREFACE?$INCR,DATA?$INCR> → <INTEGER>
27000 BEGIN INTEGER HAD,DATA,REG;
27100 HAD←DATA?$SIZEF(FLD)-1;
27200 DATA←EX?$BLOCK(FLD,PREFACE?$INCR,DATA?$INCR);
27300 IF BOOLE(1, REG←IDENTITY(BACK?$POINTER(FIND?$HEADER(DATA)),INTEGER), `17000000)=0 THEN
27400 RHALF(_RH(REG)) ← DATA ; % E.G., RHALF(_MP_) ← .SYSMAP %
27500 RETURN HAD;
27600 END;
27700
27800
27900
28000 LET FORGET?$SPACE = <INTEGER:BLK> → NIL &
28100 BEGIN
28200 INTEGER L, N ;
28300 L ← (LAST_PHYSICAL(BLK)) ;
28400 N ← (NEXT_PHYSICAL(BLK)) ;
28500 IF OCCUPIED(L) = 0 THEN
28600 BEGIN
28700 NEXT_PHYSICAL(L) ← N ;
28800 LAST_PHYSICAL(N) ← L ;
28900 BLK ← L ;
29000 END
29100 ELSE BEGIN
29200 LAST_FREE(BLK) ← 0;
29300 NEXT_FREE(BLK) ← FREE?$BLOCKS;
29400 OCCUPIED(BLK) ← 0 ; SWEEPABLE(BLK) ← 0 ;
29500 IF FREE?$BLOCKS ≠ 0 THEN LAST_FREE(FREE?$BLOCKS) ← BLK;
29600 FREE?$BLOCKS ← BLK;
29700 END;
29800 IF OCCUPIED(N) = 0 THEN
29900 BEGIN INTEGER NN;
30000 NN ← (NEXT_PHYSICAL(N)) ;
30100 NEXT_PHYSICAL(BLK) ← NN ;
30200 LAST_PHYSICAL(NN) ← BLK ;
30300 IF NEXT_FREE(N) ≠ 0 THEN LAST_FREE((NEXT_FREE(N))) ←LAST_FREE(N);
30400 IF LAST_FREE(N) ≠ 0 THEN NEXT_FREE((LAST_FREE(N))) ←NEXT_FREE(N);
30500 END ;
30600 CONTRACT?$CORE() ;
30700 END ;
30800
30900
31000 LET GET?$BLOCK = :DESC <INTEGER:PREFACE,DATA?$SIZE,BROOM> → <INTEGER>
31100 BEGIN INTEGER HEDR, DATA ;
31200 HEDR ← GET?$SPACE(BLOCK?$HEADER?$LENGTH + PREFACE + 1 + DATA?$SIZE);
31300 SWEEPABLE(HEDR) ← BROOM ;
31400 DATA ← HEDR + BLOCK?$HEADER?$LENGTH + PREFACE + 1 ;
31500 RHALF(_EFFECTIVE(DESC)) ← DATA; % MAP TABLE ENTRY %
31600 _CORE(HEDR+2) ← DESC;
31700 TO_HEADER(DATA) ← DATA-HEDR;
31800 TO_BACK_POINTER(DATA ) ← DATA-HEDR-2;
31900 RETURN DATA;
32000 END;
32100
32200 LET OUT?$OF?$CORE = <INTEGER:LEN> → NIL &
32300 BEGIN
32400 INTEGER NEWTOP ;
32500 NEWTOP ← RHALF(`44) + 1 + ((LEN+1023)/1024)*1024 - BLOCK?$HEADER?$LENGTH ;
32600 IF LEN > 0 THEN PRINTSTR "EXPANDING CORE"
32700 ELSE IF LEN < 0 THEN PRINTSTR "CONTRACTING CORE" ;
32800 IF ¬_CALLI(_VAL_, `11, NEWTOP+BLOCK?$HEADER?$LENGTH-1) THEN
32900 ERROR("CAN'T EXPAND CORE") ;
33000 NEXT_PHYSICAL(CORE?$TOP) ← NEWTOP ;
33100 LAST_PHYSICAL(NEWTOP) ← CORE?$TOP ;
33200 NEXT_PHYSICAL(NEWTOP) ← 0 ;
33300 OCCUPIED(NEWTOP) ← 1 ; SWEEPABLE(NEWTOP) ← 0 ;
33400 _CORE(NEWTOP+2) ← NIL ; % BACK POINTER %
33500 IF LEN ≥ 0 THEN
33600 IF RHALF(`116) %DDT SYMBOLS% > CORE?$TOP THEN NIL %DON'T FORGET SYMBOL BLOCK%
33700 ELSE FORGET?$SPACE(CORE?$TOP) ;
33800 CORE?$TOP ← NEWTOP ;
33900 END ;
34000
34100
34200 LET CONTRACT?$CORE = <> → NIL &
34300 BEGIN
34400 INTEGER TOP?$FREE, TOP?$FREE?$SIZE ;
34500 TOP?$FREE ← LAST_PHYSICAL(CORE?$TOP) ; TOP?$FREE?$SIZE ← CORE?$TOP - TOP?$FREE ;
34600 IF OCCUPIED(TOP?$FREE)=1 OR TOP?$FREE?$SIZE < 2048 THEN RETURN NIL ;
34700 CORE?$TOP ← TOP?$FREE ; OUT?$OF?$CORE(-TOP?$FREE?$SIZE) ;
34800 END ;
34900
35000
35100 LET GET?$SPACE = <INTEGER:LEN> → <INTEGER>
35200 BEGIN INTEGER FB, SIZE ;
35300 FB ← FREE?$BLOCKS;
35400 WHILE FB≠0 &
35500 ((SIZE ← NEXT_PHYSICAL(FB)-FB) < LEN | (SIZE>LEN & SIZE<LEN+BLOCK?$HEADER?$LENGTH)) DO
35600 BEGIN FB ← NEXT_FREE(FB) END ; % WHILE-VALUE IS NIL %
35700 IF FB=0 THEN OUT?$OF?$CORE(LEN) ALSO RETURN GET?$SPACE(LEN) % NO FREE BLOCKS BIG ENOUGH %
35800 ELSE IF LEN = SIZE THEN % FREE BLOCK EXACTLY THE RIGHT SIZE! %
35900 BEGIN
36000 OCCUPIED(FB) ← 1;
36100 IF LAST_FREE(FB)≠0 THEN NEXT_FREE((LAST_FREE(FB))) ← NEXT_FREE(FB)
36200 ELSE FREE?$BLOCKS ← (NEXT_FREE(FB)) ;
36300 IF NEXT_FREE(FB)≠0 THEN LAST_FREE((NEXT_FREE(FB))) ← LAST_FREE(FB) ;
36400 END
36500 ELSE BEGIN INTEGER B; % FREE BLOCK LARGER THAN NEEDED %
36600 B ← FB + LEN;
36700 LAST_PHYSICAL(B) ← FB; % CREATE A NEW (SHORTER) FREE BLOCK %
36800 NEXT_PHYSICAL(B) ← NEXT_PHYSICAL(FB);
36900 IF LAST_FREE(FB)=0 THEN LAST_FREE(B) ← 0 ALSO FREE?$BLOCKS ← B
37000 ELSE LAST_FREE(B) ← LAST_FREE(FB) ALSO NEXT_FREE((LAST_FREE(B))) ← B ;
37100 IF NEXT_FREE(FB)=0 THEN NEXT_FREE(B) ← 0
37200 ELSE NEXT_FREE(B) ← NEXT_FREE(FB) ALSO LAST_FREE((NEXT_FREE(B))) ← B ;
37300 LAST_PHYSICAL((NEXT_PHYSICAL(FB))) ← B;
37400 NEXT_PHYSICAL(FB) ← B;
37500 OCCUPIED(FB) ← 1; OCCUPIED(B) ← 0 ; SWEEPABLE(B) ← 0 ;
37600 END;
37700 RETURN FB;
37800 END;
37900
38000
38100
38200
38300 LET APPEND = (::X) (::Y) → (::X ::Y) ;
38400
38500
38600 LET ASSOC = <IDENTIFIER:X> <LIST:L> → <LIST>
38700 FOR PRIVATE Y IN L SEARCH UNTIL X EQ CAR(Y) IN WHICH CASE Y OTHERWISE NIL ;
38800
38900 LET LAST = (... :X) → :X ;
39000 ELSE LAST(CDR L);
39100
39200 LET LENGTH = <LIST:L> → <INTEGER>
39300 BEGIN INTEGER I;
39400 FOR PRIVATE J IN L DO I←I+1;
39500 RETURN I;
39600 END;
39700
39800 = <STRING|VECTOR|TUPLE:L> → <INTEGER> ELEMENTS(DATA?$AREA(L)) ;
39900 = :OTHER → 0 ;
40000
40100 LET MEMBER = :X <LIST:L> → <BOOLEAN>
40200 IF ¬L THEN NIL
40300 ELSE IF X=L[1] THEN 'T
40400 ELSE X MEMBER CDR L;
40500
40600 LET MEMQ = <IDENTIFIER:X> <LIST:L> → <BOOLEAN>
40700 IF ¬L THEN NIL
40800 ELSE IF X EQ L[1] THEN 'T
40900 ELSE X MEMQ CDR L;
41000
41100
41200 LET REVERSE = <LIST:L> → <LIST>
41300 BEGIN LIST TMP;
41400 FOR PRIVATE I IN L DO TMP←I CONS TMP;
41500 RETURN TMP;
41600 END;
41700
41800
41900 LET XCONS = (::X) :Y → (:Y ::X) ;
42000
42100 LET SUBST = :X :Y :Z → <ENTITY>
42200 IF Y=Z THEN X
42300 ELSE IF ATOM Z THEN Z
42400 ELSE SUBST(X,Y,CAR Z) CONS SUBST(X,Y,CDR Z);
42500
42600 LET MAP = <IDENTIFIER:FN> <LIST:L> → NIL &
42700 FOR LIST I ON L DO (FN.FUNCTION)(I);
42800
42900 LET MAPC = <IDENTIFIER:FN> <LIST:L> → NIL &
43000 FOR PRIVATE I IN L DO (FN.FUNCTION)(I);
43100
43200 LET MAPLIST = <IDENTIFIER:FN> <LIST:L> → <LIST>
43300 FOR LIST I ON L COLLECT [(FN.FUNCTION)(I)];
43400
43500 LET MAPCAR = <IDENTIFIER:FN> <LIST:L> → <LIST>
43600 FOR PRIVATE I IN L COLLECT [(FN.FUNCTION)(I)];
43700
43800 LET PUTPROP = <IDENTIFIER:I> :V <IDENTIFIER:P> → :V &
43900 PROPERTIES(I)←?$PP(P,V,PROPERTIES(I));
44000
44100 LET ?$PP = <IDENTIFIER:P> :V (... :P :X ...) → (... :P :V ...) ;
44200 = <IDENTIFIER:P> :V (...) → (:P :V ...) ;
44300
44400 LET GET = <IDENTIFIER:I,P> → <ENTITY>
44500 BEGIN LIST TMP;
44600 TMP←PROPERTIES(I);
44700 RETURN WHILE TMP DO
44800 BEGIN
44900 IF P EQ TMP[1] THEN RETURN (TMP[2] PROG1 TMP←NIL);
45000 TMP←CDDR TMP;
45100 END;
45200 END;
45300
45400 LET GETL = <IDENTIFIER:I> <LIST:L> → <LIST>
45500 BEGIN LIST TMP;
45600 TMP←PROPERTIES(I);
45700 RETURN WHILE TMP DO
45800 BEGIN
45900 IF TMP[1] MEMQ L THEN RETURN (TMP PROG1 TMP←NIL);
46000 TMP←CDDR TMP;
46100 END;
46200 END;
46300
46400 LET REMPROP = <IDENTIFIER:I,P> → <BOOLEAN>
46500 BEGIN LIST TMP;BOOLEAN VAL;
46600 TMP←PROPERTIES(I);
46700 PROPERTIES(I)←WHILE TMP COLLECT
46800 IF TMP[1] EQ P THEN VAL←'T ALSO NIL
46900 ELSE [TMP[1], TMP[2]] PROG1 TMP←CDDR TMP;
47000 RETURN VAL;
47100 END;
47200
47300 LET SET = <IDENTIFIER:VAR> :EX → :EX &
47400 BEGIN PUBIC?$VARIABLE Q ;
47500 Q←VAR.PUBLIC;
47600 IF ¬Q THEN VAR.PUBLIC←PUBIC?$VARIABLE(EX)
47700 ELSE VALUE(Q)←EX;
47800 END;
47900
48000 LET EVAL = <IDENTIFIER:VAR> → <: VALUE(VAR.PUBLIC> ;
48100
48200
48300 LET INDEX
48400 = <LIST:L> <INTEGER:I> <BOOLEAN:STO> → <ENTITY>
48500 IF STO THEN ERROR("LIST INDEXED STORE UNIMPLEMENTED")
48600 ELSE BEGIN
48700 LIST M ; INTEGER J ;
48800 M ← L ; J ← I ;
48900 WHILE ¬ATOM M & (J ← J - 1) ≥ 1 DO M ← CDR M ;
49000 IF ATOM M THEN PRINT('INDEX CONS L CONS [I]) ALSO ERROR(" INDEXES AN ATOM") ;
49100 ELSE RETURN CAR M ;
49200 END ;
49300
49400
49500 = <STRING:L> <INTEGER:I> <BOOLEAN:STO> → <ENTITY>
49600 IF I≤1 OR I>LENGTH(L) THEN PRINT L ALSO PRINT I ALSO ERROR("STRING INDEX")
49700 ELSE BEGIN
49800 INTEGER WD, BYT, PTR ;
49900 WD ← (I-1)/5 ; BYT ← (I-1) REMAINDER 5 ;
50000 PTR ← _POINT(7, _CORE(DATA?$AREA(L)+WD), 29-7*BYT) ;
50100 RETURN IF STO EQ '_FETCH THEN _LDB(PTR) ELSE _DPB(PTR, STO) ;
50200 END ;
50300
50400
50500 = :L <INTEGER:I> <BOOLEAN:STO> → <ENTITY>
50600 BEGIN INTEGER S ;
50700 IF I≤1 OR I>LENGTH(L) THEN PRINT L ALSO ERROR("GENERAL INDEX")
50800 ELSE IF (S ← LSH(LHALF(_EFFECTIVE(L)), -23))≠0 THEN
50900 BEGIN
51000 INTEGER WD, BYT, PTR ;
51100 WD ← (I-1)/(36/S) ;
51200 BYT ← (I-1) REMAINDER (36/S) ;
51300 PTR ← _POINT(S, _CORE(DATA?$AREA(L)+WD), 36-S*(BYT+1)) ;
51400 RETURN IF STO EQ '_FETCH THEN _LDB(PTR) ELSE _DPB(PTR, STO) ;
51500 END
51600 ELSE IF STO EQ '_FETCH THEN _CORE(DATA?$AREA(L)+I-1)
51700 ELSE _CORE(DATA?$AREA(L)+I-1) ← STO ;
51800 END ;
51900
52000
52100 LET MKN?$LIST = <INTEGER:NILS> → <LIST>
52200 IF NILS ≤ 0 THEN NIL
52300 ELSE CONS(NIL, MKN?$LIST(NILS-1)) ;
52400
52500
52600 LET SIXBIT = :SEQ → <INTEGER> SIXBIT1(SEQ:1:LENGTH(SEQ)) ;
52700
52800 LET SIXBIT1 = :SEQ <INTEGER:LO,HI> → <INTEGER>
52900 IF HI < LO THEN 0
53000 ELSE BEGIN
53100 INTEGER SIX ;
53200 FOR INTEGER I ← 0 TO 5 DO
53300 SIX ← BOOLE(7, LSH(SIX, 6),
53400 IF I>HI-LO THEN 0
53500 ELSE (X[LO+I]-`40) REMAINDER `100
53600 ) ;
53700 RETURN SIX ;
53800 END ;
53900
54000 LET PPN = <INTEGER:PJ,PN> → <INTEGER>
54100 BEGIN
54200 IF PJ≠0 THEN WHILE BOOLE(1, PJ, `177) = 0 DO PJ ← LSH(PJ, -7) ;
54300 IF PN≠0 THEN WHILE BOOLE(1, PN, `177) = 0 DO PN ← LSH(PN, -7) ;
54400 RETURN BOOLE(7, LSH(PJ, 18), PN) ;
54500 END ;
54600
54700
54800 LET FOUTCHR = <FILE:FIL> <INTEGER:CHR> → NIL &
54900 IF CHR < 0 THEN CLOSE(FIL)
55000 ELSE BEGIN
55100 INTEGER H ;
55200 H ← HEADER(FIL) + 2 ;
55300 IF (RHALF(H) ← SUB1(RHALF(H))) ≤ 0 & IOUUO(%OUT%`57, CHANNEL?$NUMBER(FIL), 0) THEN
55400 PRINT FIL ALSO ERROR("OUTCHR") ;
55500 _IDPB(H-1, CHR) ;
55600 END ;
55700
55800
55900 LET INPUT = <STRING:NAME> → <FILE>
56000 OPEN(FILE(NAME, -1, 'ASCII, 0, 'T, LISP70_SCANNER,
56100 SEQUENCE(100, [LSH(100,18)]), 2, `200, 0)) ;
56200
56300
56400 LET LOC?$BUFFER = <FILE:FIL> → <INTEGER>
56500 BUFFER?$HEADERS + 8*CHANNEL?$NUMBER(FIL) + (IF FOR?$INPUT(FIL) THEN 0 ELSE 4) ;
56600
56700
56800 LET OUTPUT = <STRING:NAME> → <FILE>
56900 OPEN(FILE(NAME, -1, 'ASCII, 0, NIL, NIL, "", 2, `200, 0)) ;
57000
57100
57200 LET START_SCAN = <FILE:FIL> <SCN?$TABLE:S> → <FILE>
57300 BEGIN
57400 SCANNER(FIL) ← S ;
57500 SCN?$STRING(FIL) ← SEQUENCE(100) ;
57600 RETURN FIL ;
57700 END ;
57800
57900
58000 LET FOUTSTR = <FILE:FIL> <STRING:S> → NIL &
58100 FOR INTEGER I ← 1 TO LENGTH(S) DO FOUTCHR(FIL, I) ;
58200
58300
58400 LET DISSECT = :X <INTEGER:LO,HI,DISSECTOR> → <INTEGER>
58500 FOR INTEGER I ← LO TO HI SEARCH UNTIL X[I] = DISSECTOR IN WHICH CASE I OTHERWISE HI+1 ;
58600
58700
58800 LET CONVERT_FILE_NAME = <STRING:S> → <LIST>
58900 BEGIN
59000 INTEGER LO, HI, D, DEV, FNAME, EXT, PJ, PN ;
59100 LO ← 1 ; HI ← LENGTH(S) ;
59200 D ← DISSECT(S, LO, HI, ":"[1]) ;
59300 IF D>HI THEN DEV ← SIXBIT("DSK")
59400 ELSE DEV ← SIXBIT1(S,LO,D-1) ALSO LO←D+1 ;
59500 D ← DISSECT(S, LO, HI, "."[1]) ;
59600 IF D>HI THEN D ← DISSECT(S, LO, HI, "[" [1]) ;
59700 FNAME ← SIXBIT1(S, LO, D-1) ; LO ← D+1 ;
59800 D ← DISSECT(S, LO, HI, "[" [1]) ;
59900 EXT ← SIXBIT1(S, LO,D-1) ; LO ← D+1 ;
60000 D ← DISSECT(S, LO, HI, ","[1]) ;
60100 PJ ← SIXBIT1(S, LO, D-1) ; LO ← D+1 ;
60200 D ← DISSECT(S, LO, HI, "]" [1]) ;
60300 PN ← SIXBIT1(S, LO, HI, D-1) ; LO ← D+1 ;
60400 IF D ≤ HI THEN PRINT S ALSO ERROR("BAD FILE NAME") ;
60500 RETURN [DEV, FNAME, EXT, PJ, PN] ;
60600 END ;
60700
60800
60900 LET OPEN = <FILE:FIL> → <FILE>
61000 BEGIN
61100 LIST CF, CHAN ; INTEGER J, JOBFF ; TUPLE BUFFS ;
61200 CHANNEL(FIL) ← CHAN ← GET?$CHANNEL?$NUMBER() ;
61300 HEADER(FIL) ← LOC?$BUFFER(FIL) ;
61400 CF ← CONVERT?$FILE?$NAME(NAME(FIL)) ; % CF = (DEV FNAME EXT PJ PN) IN SIXBIT %
61500 INITUUO(CHAN,
61600 IF MODE(FIL) EQ 'ASCII THEN 0 ELSE `17,
61700 CF[1] % DEVICE % ) ;
61800 IF ¬FILEUUO(IF FOR?$INPUT(FIL) THEN %LOOKUP%`76 ELSE %ENTER%`77,
61900 CHAN, CF[2], CF[3], PPN(CF[4], CF[5])) THEN
62000 PRINT NAME(FIL) ALSO ERROR("LOOKUP ERROR") ;
62100 IF MODE(FIL) EQ 'ASCII THEN
62200 BEGIN
62300 JOBFF ← `121 ; J ← RHALF(JOBFF) ; % LOCATE BUFFER RINGS %
62400 BUFFS ← SEQUENCE(NO?$OF?$BUFFERS(FIL)*(3+BUFFER?$SIZE(FIL))) ;
62500 RHALF(JOBFF) ← DATA?$AREA(BUFFS) ;
62600 IOUUO(IF FOR?$INPUT(FIL) THEN %INBUF%`64 ELSE %OUTBUF%`65,
62700 CHAN, NO?$OF?$BUFFERS(FIL)) ;
62800 IF FOR?$INPUT(FIL) THEN IOUUO(%IN%`56, CHAN, 0) ;
62900 RHALF(JOBFF) ← J ;
63000 END ;
63100 RETURN FIL ;
63200 END ;
63300
63400
63500 LET GET?$CHANNEL?$NUMBER = <> → <INTEGER>
63600 FOR INTEGER CHAN ← 0 TO 15 SEARCH UNTIL ¬BUSY?$CHANNELS[CHAN+1]
63700 IN WHICH CASE (BUSY?$CHANNELS[CHAN+1] ← T) PROG2 CHAN
63800 OTHERWISE ERROR("NO CHANNELS AVAILABLE") ;
63900
64000
64100 LET CLOSE = <FILE:FIL> → <FILE>
64200 BEGIN
64300 INTEGER CHAN ;
64400 IOUUO(%RELEASE%`71, CHAN←CHANNEL(FIL), 0) ;
64500 REL?$CHANNEL?$NUMBER(CHAN) ;
64600 CHANNEL(FIL) ← -1 ;
64700 RETURN FIL ;
64800 END ;
64900
65000
65100 LET REL?$CHANNEL?$NUMBER = <INTEGER:CHAN> → NIL &
65200 BUSY?$CHANNELS[CHAN+1] ← NIL ;
65300
65400
65500 LET FINCHR = <FILE:FIL> → <INTEGER>
65600 BEGIN
65700 INTEGER H ;
65800 H ← LOC?$HEADER(FIL) + 2 ;
65900 RETURN
66000 IF (RHALF(H)←SUB1(RHALF(H))) ≤ 0 & IOUUO(%IN%`56, CHANNEL?$NUMBER(FIL), 0) THEN
66100 IF IOUUO(%STATO%`61, `20000) THEN %EOF% CLOSE(FIL) ALSO -1
66200 ELSE PRINT NAME(FIL) ALSO ERROR("INCHR") ALSO -1
66300 ELSE _ILDB(H-1) ;
66400 END ;
66500
66600
66700 LET MK?$SEQUENCE = <TYPE:TYP> <INTEGER:BLK?$DATA,BYTE?$SIZE> :ELEMTS :PREFACEWDS → <TYP>
66800 BEGIN
66900 DESCR ← MK?$SQ(TYP, BLK?$DATA, BYTE?$SIZE, LENGTH(ELEMTS), LENGTH(PREFACEWDS)) ;
67000 BKPTR ← FIND?$BACK?$POINTER(DATA?$AREA(DESCR)) ;
67100 FOR PRIVATE X IN PREFACEWDS FOR INTEGER I ← 1 TO INFINITY DO
67200 _CORE(BKPTR + I) ← X ;
67300 FOR PRIVATE X IN ELEMTS FOR INTEGER I ← 1 TO INFINITY DO
67400 DESCR[I] ← X ;
67500 RETURN DESCR ;
67600 END ;
67700
67800
67900 LET MKN?$SEQUENCE = <TYPE:TYP> <INTEGER:BLK?$DATA,BYTE?$SIZE> <INTEGER:NILS> :PREFACEWDS → <TYP>
68000 BEGIN
68100 DESCR ← MK?$SQ(TYP, BLK?$DATA, BYTE?$SIZE, NILS, LENGTH(PREFACEWDS)) ;
68200 BKPTR ← FIND?$BACK?$POINTER(DATA?$AREA(DESCR)) ;
68300 FOR PRIVATE X IN PREFACEWDS FOR INTEGER I ← 1 TO INFINITY DO
68400 _CORE(BKPTR + I) ← X ;
68500 FOR INTEGER I ← 1 TO NILS DO
68600 DESCR[I] ← IF BYTE?$SIZE=0 THEN NIL ELSE 0 ;
68700 RETURN DESCR ;
68800 END ;
68900
69000
69100 LET MK?$SQ = <TYPE:TYP> <INTEGER:BLK?$DATA,BYTE?$SIZE,ELEMS,PREFS> → <TYP>
69200 BEGIN
69300 INTEGER AVAIL, BLOCK, DWDS, TWDS, DATA ;
69400 DWDS ← IF TYP = STRING?$TYPE THEN ELEMS/5 + 1
69500 ELSE IF BYTE?$SIZE ≠ 0 THEN (ELEMS-1)/(36/BYTE?$SIZE) + 1
69600 ELSE ELEMS ;
69700 TWDS ← DWDS + PREFS + 3 ;
69800 DO BEGIN
69900 BLOCK ← FIND?$HEADER(BLK?$DATA) ;
70000 AVAIL ← TO_FREE_VECTOR(BLK?$DATA) ;
70100 IF AVAIL + TWDS ≥ NEXT_PHYSICAL(BLOCK) THEN
70200 BLK?$DATA ← GET?$BLOCK(BACK?$POINTER(BLOCK), 1, TWDS+1 MAX 200, SWEEPABLE(BLOCK))
70300 ALSO BLOCK ← 0 ;
70400 END
70500 UNTIL BLOCK ≠ 0 ;
70600 DATA ← AVAIL + PREFS + 3 ;
70700 TO_NEXT_VECTOR(RHALF(AVAIL)+BLK?$DATA) ← DATA - BLK?$DATA ;
70800 TO_NEXT_VECTOR(DATA) ← 0 ;
70900 ELEMENTS(DATA) ← ELEMS ;
71000 TO_HEADER(DATA) ← DATA - BLOCK ;
71100 TO_BACK_POINTER(DATA) ← DATA - AVAIL ;
71200 _CORE(AVAIL, INTEGER) ← BOOLE(7,
71300 _ADDRESS(MAP?$CELL(BOOLE(7,
71400 LSH(BYTE?$SIZE, 23),
71500 DATA))),
71600 _CORE(BLK?$DATA-3, INTEGER)) ;
71700 TO_FREE_VECTOR(BLK?$DATA) ← AVAIL + TWDS - BLK?$DATA ;
71800 RHALF(AVAIL+TWDS) ← DATA - BLK?$DATA ;
71900 IF BYTE?$SIZE ≠ 0 AND DWDS ≠ 0 THEN _CORE(DATA+DWDS-1) ← NIL ;
72000 RETURN _CORE(AVAIL) ;
72100 END ;
72200
72300
72400 % LISP70 BOOTSTRAP
72500
72600 DESCRIPTOR FORMAT:
72700
72800 _________________________________________________
72900 | | | | | |
73000 | | | | | |
73100 | TYPE | |0|BASE| DISPLACEMENT |
73200 | | | | | |
73300 |______________|_|_|____|_______________________|
73400 \____________/ \__/ \______________________/
73500 12 4 18
73600 BITS BITS BITS
73700
73800
73900
74000 %
74100 LET BLOCK?$HEADER = :DESC → <INTEGER> FIND?$HEADER(DATA?$AREA(DESC)) ;
74200
74300
74400
74500
74600 LET DATA?$AREA = :DESC → <INTEGER>
74700 _ADDRESS(_CORE(_EFFECTIVE(DESC))) ;
74800
74900
75000 LET DATA?$SIZEF = :DESC → <INTEGER> NEXT_PHYSICAL(BLOCK?$HEADER(DESC)) - DATA?$AREA(DESC) ;
75100
75200
75300
75400 LET FIND?$BACK?$POINTER = <INTEGER:ADDR> → <INTEGER>
75500 ADDR - TO_BACK_POINTER(ADDR) ;
75600
75700
75800
75900 LET FIND?$HEADER = <INTEGER:ADDR> → <INTEGER>
76000 ADDR - TO_HEADER(ADDR) ;
76100
76200
76300 LET FIND?$NEXT?$VECTOR = <INTEGER:VDA> → <INTEGER>
76400 ADDR + TO_NEXT_VECTOR(VDA) ;
76500
76600 LET PREFACEF = :DESC → <INTEGER>
76700 TO_BACK_POINTER(DATA?$AREA(DESC)) -2 ;
76800
76900 RELOCATABILITY UNSHARED ;
77000
77100
77200 _EOF_
77300